home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / clx.lha / clx / depdefs.l < prev    next >
Lisp/Scheme  |  1988-09-12  |  11KB  |  331 lines
  1. ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
  2.  
  3. ;; This file contains some of the system dependent code for CLX
  4.  
  5. ;;;
  6. ;;;             TEXAS INSTRUMENTS INCORPORATED
  7. ;;;                  P.O. BOX 2909
  8. ;;;                   AUSTIN, TEXAS 78769
  9. ;;;
  10. ;;; Copyright (C) 1987 Texas Instruments Incorporated.
  11. ;;;
  12. ;;; Permission is granted to any individual or institution to use, copy, modify,
  13. ;;; and distribute this software, provided that this complete copyright and
  14. ;;; permission notice is maintained, intact, in all copies and supporting
  15. ;;; documentation.
  16. ;;;
  17. ;;; Texas Instruments Incorporated provides this software "as is" without
  18. ;;; express or implied warranty.
  19. ;;;
  20.  
  21. (in-package 'xlib :use '(lisp))
  22.  
  23. ;;;-------------------------------------------------------------------------
  24. ;;; CLX can maintain a mapping from X server ID's to local data types.  If
  25. ;;; one takes the view that CLX objects will be instance variables of
  26. ;;; objects at the next higher level, then PROCESS-EVENT will typically map
  27. ;;; from resource-id to higher-level object.  In that case, the lower-level
  28. ;;; CLX mapping will almost never be used (except in rare cases like
  29. ;;; query-tree), and only serve to consume space (which is difficult to
  30. ;;; GC), in which case always-consing versions of the make-<mumble>s will
  31. ;;; be better.  Even when maps are maintained, it isn't clear they are
  32. ;;; useful for much beyond xatoms and windows (since almost nothing else
  33. ;;; ever comes back in events).
  34. ;;;--------------------------------------------------------------------------
  35. (defconstant *clx-cached-types*
  36.          '( drawable
  37.         window
  38.         pixmap
  39. ;        gcontext
  40.         cursor
  41.         colormap
  42.         font
  43.         xatom))
  44.  
  45. (defmacro resource-id-map-test ()
  46.   #+excl '#'equal
  47.   #-excl (if #.(> #x1fffffff most-positive-fixnum) '#'eql '#'eq))
  48.  
  49. ;;; If you use overlapping-arrays, you must define this to match the
  50. ;;; real byte order (which probably means uncommenting it).  Otherwise,
  51. ;;; you can choose the byte order to match the byte order of the servers
  52. ;;; you talk to most frequently.
  53.  
  54. #+(or explorer genera)
  55. (eval-when (eval compile load)
  56.   (pushnew :clx-little-endian *features*))
  57.  
  58. ;;; Steele's Common-Lisp states:  "It is an error if the array specified
  59. ;;; as the :displaced-to argument  does not have the same :element-type
  60. ;;; as the array being created" If this is the case on your lisp, then
  61. ;;; leave the overlapping-arrays feature turned off.  Lisp machines
  62. ;;; (Symbolics TI and LMI) don't have this restriction, and allow arrays
  63. ;;; with different element types to overlap.  CLX will take advantage of
  64. ;;; this to do fast array packing/unpacking when the overlapping-arrays
  65. ;;; feature is enabled.
  66.  
  67. #+(and clx-little-endian lispm)
  68. (eval-when (eval compile load)
  69.   (pushnew :clx-overlapping-arrays *features*))
  70.  
  71. #+(and clx-overlapping-arrays genera)
  72. (progn
  73. (deftype overlap16 () '(unsigned-byte 16))
  74. (deftype overlap32 () '(signed-byte 32))
  75. )
  76.  
  77. #+(and clx-overlapping-arrays (or explorer lambda cadr))
  78. (progn
  79. (deftype overlap16 () '(unsigned-byte 16))
  80. (deftype overlap32 () '(unsigned-byte 32))
  81. )
  82.  
  83. (deftype buffer-bytes () `(simple-array (unsigned-byte 8) (*)))
  84.  
  85. #+clx-overlapping-arrays
  86. (progn
  87. (deftype buffer-words () `(vector overlap16))
  88. (deftype buffer-longs () `(vector overlap32))
  89. )
  90.  
  91. ;;; This defines a type which is a subtype of the integers.
  92. ;;; This type is used to describe all variables that can be array indices.
  93. ;;; It is here because it is used below.
  94. ;;; This is inclusive because start/end can be 1 past the end.
  95. (deftype array-index () `(integer 0 ,array-dimension-limit))
  96.  
  97. ;; this is the best place to define these?
  98.  
  99. (defun make-index-typed (form)
  100.   (if (integerp form)
  101.       form
  102.       `(the array-index ,form)))
  103.  
  104. (defmacro index+ (&rest numbers)
  105.   `(the array-index (+ ,@(mapcar #'make-index-typed numbers))))
  106. (defmacro index-logand (&rest numbers)
  107.   `(the array-index (logand ,@(mapcar #'make-index-typed numbers))))
  108. (defmacro index-logior (&rest numbers)
  109.   `(the array-index (logior ,@(mapcar #'make-index-typed numbers))))
  110. (defmacro index- (&rest numbers)
  111.   `(the array-index (- ,@(mapcar #'make-index-typed numbers))))
  112. (defmacro index* (&rest numbers)
  113.   `(the array-index (* ,@(mapcar #'make-index-typed numbers))))
  114.  
  115. (defmacro index1+ (number)
  116.   `(the array-index (1+ (the array-index ,number))))
  117. (defmacro index1- (number)
  118.   `(the array-index (1- (the array-index ,number))))
  119.  
  120. ;;; CLtL Page 96 -Slyme loses
  121. (defmacro index-incf (place &optional (delta 1))
  122.   #+genera `(setf ,place (index+ ,place ,delta))
  123.   #-genera `(incf (the array-index ,place) (the array-index ,delta)))
  124. (defmacro index-decf (place &optional (delta 1))
  125.   #+genera `(setf ,place (index- ,place ,delta))
  126.   #-genera `(decf (the array-index ,place) (the array-index ,delta)))
  127.  
  128. (defmacro index-min (&rest numbers)
  129.   `(the array-index (min ,@(mapcar #'make-index-typed numbers))))
  130. (defmacro index-max (&rest numbers)
  131.   `(the array-index (max ,@(mapcar #'make-index-typed numbers))))
  132.  
  133. (defmacro index-floor (number &optional divisor)
  134.   `(the array-index
  135.     (values (floor (the array-index ,number)
  136.                ,@(when divisor `((the array-index ,divisor)))))))
  137. (defmacro index-ceiling (number &optional divisor)
  138.   `(the array-index
  139.     (values (ceiling (the array-index ,number)
  140.              ,@(when divisor `((the array-index ,divisor)))))))
  141. (defmacro index-truncate (number &optional divisor)
  142.   `(the array-index
  143.     (values (truncate (the array-index ,number)
  144.               ,@(when divisor `((the array-index ,divisor)))))))
  145. (defmacro index-mod (number divisor)
  146.   `(the array-index
  147.     (mod (the array-index ,number) (the array-index ,divisor))))
  148.  
  149. (defmacro index-ash (number count)
  150.   `(the array-index
  151.     (ash (the array-index ,number) (the fixnum ,count))))
  152.  
  153. (defmacro index-plusp (number)
  154.   `(plusp (the array-index ,number)))
  155. (defmacro index-zerop (number)
  156.   `(zerop (the array-index ,number)))
  157.  
  158. (defmacro index> (&rest numbers)
  159.   `(> ,@(mapcar #'make-index-typed numbers)))
  160. (defmacro index= (&rest numbers)
  161.   `(= ,@(mapcar #'make-index-typed numbers)))
  162. (defmacro index< (&rest numbers)
  163.   `(< ,@(mapcar #'make-index-typed numbers)))
  164. (defmacro index>= (&rest numbers)
  165.   `(>= ,@(mapcar #'make-index-typed numbers)))
  166. (defmacro index<= (&rest numbers)
  167.   `(<= ,@(mapcar #'make-index-typed numbers)))
  168.  
  169. #-lispm
  170. (proclaim '(declaration arglist values))
  171.  
  172. #+lispm
  173. (defmacro declare-arglist (&rest args)
  174.   `(declare (sys:arglist ,@args)))
  175.  
  176. #-lispm
  177. (defmacro declare-arglist (&rest args)
  178.   `(declare (arglist ,@args)))
  179.  
  180. #+lispm
  181. (defmacro declare-values (&rest vals)
  182.   `(declare (sys:values ,@vals)))
  183.  
  184. #-lispm
  185. (defmacro declare-values (&rest vals)
  186.   `(declare (values ,@vals)))
  187.  
  188. #+genera
  189. (defmacro declare-array (type &rest vars)
  190.   `(declare (type ,type ,@vars)
  191.         (sys:array-register ,@vars)))
  192.  
  193. #-genera
  194. (defmacro declare-array (type &rest vars)
  195.   `(declare (type ,type ,@vars)))
  196.  
  197. #+lispm
  198. (defmacro declare-funarg (type &rest vars)
  199.   `(declare (type ,type ,@vars)
  200.         (sys:downward-funarg ,@vars)))
  201.  
  202. #-lispm
  203. (defmacro declare-funarg (type &rest vars)
  204.   `(declare (type ,type ,@vars)))
  205.  
  206. #+genera
  207. (defmacro with-vector ((var type) &body body)
  208.   `(let ((,var ,var))
  209.      (declare-array ,type ,var)
  210.      ,@body))
  211.  
  212. #-genera
  213. (defmacro with-vector ((var type) &body body)
  214.   (declare (ignore var type))
  215.   `(progn ,@body))
  216.  
  217. #+genera
  218. (defmacro within-definition ((name type) &body body)
  219.   `(sys:local-declare
  220.      ((sys:function-parent ,name ,type))
  221.      (sys:record-source-file-name ',name ',type)
  222.      ,@body))
  223.  
  224. #+explorer
  225. (defmacro within-definition ((name type) &body body)
  226.   `(zl:local-declare
  227.      ((sys:function-parent ,name ,type))
  228.      (sys:record-source-file-name ',name ',type)
  229.      ,@body))
  230.  
  231. #-(or genera explorer)
  232. (defmacro within-definition ((name type) &body body)
  233.   (declare (ignore name type))
  234.   `(progn ,@body))
  235.  
  236. (defconstant *replysize* 32.)
  237.  
  238. ;; used in defstruct initializations to avoid compiler warnings
  239. (defvar *empty-bytes* (make-sequence 'buffer-bytes 0))
  240. (proclaim '(type buffer-bytes *empty-bytes*))
  241. #+clx-overlapping-arrays
  242. (progn
  243. (defvar *empty-words* (make-sequence 'buffer-words 0))
  244. (proclaim '(type buffer-words *empty-words*))
  245. )
  246. #+clx-overlapping-arrays
  247. (progn
  248. (defvar *empty-longs* (make-sequence 'buffer-longs 0))
  249. (proclaim '(type buffer-longs *empty-longs*))
  250. )
  251.  
  252. ;; We need this here so we can define BUFFER below.
  253. ;;
  254. (defstruct (reply-buffer (:conc-name reply-) (:constructor make-reply-buffer-internal))
  255.   (size 0 :type array-index)            ;Buffer size
  256.   ;; Byte (8 bit) input buffer
  257.   (ibuf8 *empty-bytes* :type buffer-bytes)
  258.   ;; Word (16bit) input buffer
  259.   #+clx-overlapping-arrays
  260.   (ibuf16 *empty-words* :type buffer-words)
  261.   ;; Long (32bit) input buffer
  262.   #+clx-overlapping-arrays
  263.   (ibuf32 *empty-longs* :type buffer-longs)
  264.   )
  265.  
  266. (defconstant *buffer-text16-size* 256)
  267. (deftype buffer-text16 () `(simple-array (unsigned-byte 16) (,*buffer-text16-size*)))
  268.  
  269. ;; We need this here so we can define DISPLAY for CLX.
  270. ;;
  271. ;; This structure is :INCLUDEd in the DISPLAY structure.
  272. ;; Overlapping (displaced) arrays are provided for byte
  273. ;; half-word and word access on both input and output.
  274. ;;
  275. (defstruct (buffer (:constructor nil)
  276.            (:copier nil))
  277.   ;; Lock for multi-processing systems
  278.   (lock (make-process-lock))
  279.   (output-stream nil :type (or null stream))
  280.   ;; Buffer size
  281.   (size 0 :type array-index)
  282.   ;; Buffer size minus request size
  283.   (limit 0 :type array-index)
  284.   (request-number 0 :type integer)
  285.   ;; Byte position of start of last request
  286.   ;; used for appending requests and error recovery
  287.   (last-request nil :type (or null array-index))
  288.   ;; Byte position of start of last flushed request
  289.   (last-flushed-request nil :type (or null array-index))
  290.   ;; Current byte offset
  291.   (boffset 0 :type array-index)
  292.   ;; Byte (8 bit) output buffer
  293.   (obuf8 *empty-bytes* :type buffer-bytes)
  294.   ;; Word (16bit) output buffer
  295.   #+clx-overlapping-arrays
  296.   (obuf16 *empty-words* :type buffer-words)
  297.   ;; Long (32bit) output buffer
  298.   #+clx-overlapping-arrays
  299.   (obuf32 *empty-longs* :type buffer-longs)
  300.   ;; Holding buffer for 16-bit text
  301.   (tbuf16 (make-sequence 'buffer-text16 *buffer-text16-size* :initial-element 0))
  302.   ;; Probably EQ to Output-Stream
  303.   (input-stream nil :type (or null stream))
  304.   ;; Buffer for replies
  305.   (reply-buffer nil :type (or null reply-buffer))
  306.   ;; T when the host connection has gotten errors
  307.   (dead nil :type (or null (not null)))
  308.   
  309.   ;; Change these functions when using shared memory buffers to the server
  310.   ;; Function to call when writing the buffer
  311.   (write-function 'buffer-write-default)
  312.   ;; Function to call when flushing the buffer
  313.   (force-output-function 'buffer-force-output-default)
  314.   ;; Function to call when closing a connection
  315.   (close-function 'buffer-close-default)
  316.   ;; Function to call when reading the buffer
  317.   (input-function 'buffer-read-default)
  318.   )
  319.  
  320. ;; These are here because.
  321.  
  322. (defparameter *xlib-package* (find-package (string 'xlib)))
  323.  
  324. (defun xintern (&rest parts)
  325.   (intern (apply #'concatenate 'string (mapcar #'string parts)) *xlib-package*))
  326.  
  327. (defparameter *keyword-package* (find-package (string 'keyword)))
  328.  
  329. (defun kintern (name)
  330.   (intern (string name) *keyword-package*))
  331.